home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / tcsel003.zip / SCOPY.PAS < prev    next >
Pascal/Delphi Source File  |  1992-10-16  |  4KB  |  167 lines
  1. {$A+,B-,D-,E+,F-,I+,L-,N-,O-,R+,S+,V-}
  2. {$M 16384,65536,655360}
  3.  
  4. program scopy;
  5.  
  6. uses
  7.   dos,
  8.   tpdos,
  9.   sundry,
  10.   strings;
  11.  
  12. type
  13.   buffer_type = array[0..65519] of byte;
  14.   buffptr     = ^buffer_type;
  15.  
  16. var
  17.   f1,f2       : file;
  18.   fname1,
  19.   fname2,
  20.   NewFName,
  21.   OldDir      : PathStr;
  22.   SRec        : SearchRec;
  23.   errorcode   : integer;
  24.   buffer      : buffptr;
  25. const
  26.   MakeNewName : boolean = false;
  27.   FilesCopied : word = 0;
  28.   MaxHeapSize = 65520;
  29.  
  30. function IOCheck(stop : boolean; msg : string): boolean;
  31.   var
  32.     error : integer;
  33.   begin
  34.     error := IOResult;
  35.     IOCheck := (error = 0);
  36.     if error <> 0 then begin
  37.       writeln(msg);
  38.       if stop then begin
  39.         ChDir(OldDir);
  40.         halt(error);
  41.       end;
  42.     end;
  43.   end;
  44.  
  45. procedure Initialise;
  46.   var
  47.     temp  : string;
  48.     dir   : DirStr;
  49.     name  : NameStr;
  50.     ext   : ExtStr;
  51.   begin
  52.     if MaxAvail < MaxHeapSize then begin
  53.       writeln('Insufficient memory');
  54.       halt;
  55.     end
  56.     else
  57.       new(buffer);
  58.     {I-} GetDir(0,OldDir); {$I+} if IOCheck(true,'') then;
  59.     case ParamCount of
  60.       0: begin
  61.            writeln('No parameters provided');
  62.            halt;
  63.          end;
  64.       1: begin
  65.            TempStr := ParamStr(1);
  66.            if not ParsePath(TempStr,fname1,fname2) then begin
  67.              writeln('Invalid parameter');
  68.              halt;
  69.            end;
  70.            {$I-} ChDir(fname2); {$I+} if IOCheck(true,'') then;
  71.          end;
  72.       2: begin
  73.            TempStr := ParamStr(1);
  74.            if not ParsePath(TempStr,fname1,fname2) then begin
  75.              writeln('Invalid parameter');
  76.              halt;
  77.            end
  78.            else
  79.              {$I-} ChDir(fname2); {$I+} if IOCheck(true,'') then;
  80.  
  81.            TempStr := ParamStr(2);
  82.            if not ParsePath(TempStr,fname2,temp) then begin
  83.              writeln('Invalid parameter');
  84.              halt;
  85.            end;
  86.            FSplit(fname2,dir,name,ext);
  87.            if length(name) <> 0 then
  88.              MakeNewName := true;
  89.          end;
  90.     else begin
  91.            writeln('Too many parameters');
  92.            halt;
  93.          end;
  94.     end; { case }
  95.   end; { Initialise }
  96.  
  97. procedure CopyFiles;
  98.   var
  99.     result : word;
  100.  
  101.   function MakeNewFileName(fn : string): string;
  102.     var
  103.       temp  : string;
  104.       dir   : DirStr;
  105.       name  : NameStr;
  106.       ext   : ExtStr;
  107.       numb  : word;
  108.     begin
  109.       numb := 0;
  110.       FSplit(fn,dir,name,ext);
  111.       repeat
  112.         inc(numb);
  113.         if numb > 255 then begin
  114.           writeln('Invalid file name');
  115.           halt(255);
  116.         end;
  117.         ext := copy(Numb2Hex(numb),2,3);
  118.         temp := dir + name + ext;
  119.         writeln(temp);
  120.       until not ExistFile(temp);
  121.       MakeNewFileName := temp;
  122.     end; { MakeNewFileName }
  123.  
  124.  
  125.   begin
  126.     FindFirst(fname1,AnyFile,Srec);
  127.     while Doserror = 0 do begin
  128.       if (SRec.attr and $19) = 0 then begin
  129.         if MakeNewName then
  130.           NewFName := fname2
  131.         else
  132.           NewFName := SRec.name;
  133.         if ExistFile(NewFName) then
  134.           NewFName := MakeNewFileName(NewFName);
  135.         {$I-}
  136.         writeln('Copying ',SRec.name,' > ',NewFName);
  137.         assign(f1,SRec.name);
  138.         reset(f1,1);
  139.         if { =1= } IOCheck(false,'1. Cannot copy '+fname1) then begin
  140.           assign(f2,fname2);
  141.           rewrite(f2,1);
  142.           if IOCheck(false,'2. Cannot copy '+SRec.name) then
  143.             repeat
  144.               BlockRead(f1,buffer^,MaxHeapSize);
  145.               if IOCheck(false,'3. Cannot copy '+SRec.name) then
  146.                 result := 0
  147.               else begin
  148.                 BlockWrite(f2,buffer^,result);
  149.                 if IOCheck(false,'4. Cannot copy '+NewFName) then
  150.                   result := 0;
  151.               end;
  152.             until result < MaxHeapSize;
  153.           close(f1); close(f2);
  154.           if IOCheck(false,'Error while copying '+SRec.name) then;
  155.         end; { =1= }
  156.       end;  { if SRec.attr }
  157.       FindNext(Srec);
  158.     end; { while Doserror = 0 }
  159.   end; { CopyFiles }
  160.  
  161. begin
  162.   Initialise;
  163.   CopyFiles;
  164.   ChDir(OldDir);
  165. end.
  166.  
  167.